home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / parse.scm < prev    next >
Encoding:
Text File  |  1992-12-15  |  14.4 KB  |  450 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; This implements a lexer which separates tokens according to
  6. ;;; character class and a Pratt style parser.
  7. ;;; (CGOL:TOP-PARSE delimiter) returns one parsed object.  delimiter
  8. ;;; must be a character or string.
  9.  
  10. ;;; References are:
  11.  
  12. ;;; Pratt, V. R.
  13. ;;; Top Down Operator Precendence.
  14. ;;; SIGACT/SIGPLAN
  15. ;;; Symposium on Principles of Programming Languages,
  16. ;;; Boston, 1973, 41-51
  17.  
  18. ;;; WORKING PAPER 121
  19. ;;; CGOL - an Alternative External Representation For LISP users
  20. ;;; Vaughan R. Pratt
  21. ;;; MIT Artificial Intelligence Lab.
  22. ;;; March 1976
  23.  
  24. ;;; Mathlab Group,
  25. ;;; MACSYMA Reference Manual, Version Ten,
  26. ;;; Laboratory for Computer Science, MIT, 1983
  27.  
  28. (define *syn-rules* #f)
  29. (define *syn-defs* #f)
  30. (define *lex-rules* #f)
  31. (define *lex-defs* #f)
  32.  
  33. (define lex:column 0)
  34. (define lex:peek-char peek-char)
  35. (define (lex:read-char)
  36.   (let ((c (read-char)))
  37.     (if (or (eqv? c #\newline) (eof-object? c))
  38.     (set! lex:column 0)
  39.       (set! lex:column (+ 1 lex:column)))
  40.     c))
  41. (define (lex:bump-column pos)
  42.   (cond ((eqv? #\newline (lex:peek-char))
  43.      (lex:read-char)))        ;to do newline
  44.   (set! lex:column (+ lex:column pos)))
  45. (define (cgol:warn msg)
  46.   (do ((j (+ -1 lex:column) (- j 8)))
  47.       ((> 8 j)
  48.        (do ((i j (- i 1)))
  49.        ((>= 0 i))
  50.      (display-diag #\ )))
  51.     (display-diag slib:tab))
  52.   (display-diag "^ ")
  53.   (display-diag msg)
  54.   (newline-diag))
  55.  
  56. ;(require 'record)
  57. ;(define lex-rtd (make-record-type "lexrec" '(cc sfp)))
  58. ;(define lex:make-rec (record-constructor lex-rtd))
  59. ;(define lex:cc (record-accessor lex-rtd 'cc))
  60. ;(define lex:sfp (record-accessor lex-rtd 'sfp))
  61.  
  62. (define lex:make-rec cons)
  63. (define lex:cc car)
  64. (define lex:sfp cdr)
  65.  
  66. (define lex:tab-get (hash-inquirer char=?))
  67. (define lex:tab-set! (hash-associator char=?))
  68. (define (lex:def-class bp chrlst string-fun)
  69.   (for-each
  70.    (lambda (token)
  71.      (let ((oldlexrec (lex:tab-get *lex-defs* token)))
  72.        (lex:tab-set! *lex-defs* token (lex:make-rec bp string-fun))
  73.        (cond ((or (not oldlexrec) (eqv? (lex:cc oldlexrec) bp)) #t)
  74.          (else (math:warn "cc of " token " redefined to " bp)))))
  75.    chrlst))
  76.  
  77. ;;; CGOL:SXOP-LBP is the left binding power of this sxop.
  78. ;;; CGOL:SXOP-RBP is the right binding power of this sxop.
  79. ;;; CGOL:SXOP-LED is the left denotation (function to call when
  80. ;;; unclaimed token on left).
  81. ;;; CGOL:SXOP-NUD is the null denotation (function to call when no
  82. ;;; unclaimed tokens).
  83.  
  84. ;(define sxop-rtd
  85. ;  (make-record-type "sxop" '(name lame lbp rbp nud led)))
  86. ;(define cgol:make-sxop (record-constructor sxop-rtd))
  87. ;(define cgol:sxop-name (record-accessor sxop-rtd 'name))
  88. ;(define cgol:sxop-lame (record-accessor sxop-rtd 'lame))
  89. ;(define cgol:sxop-lbp (record-accessor sxop-rtd 'lbp))
  90. ;(define cgol:sxop-led (record-accessor sxop-rtd 'led))
  91. ;(define cgol:sxop-rbp (record-accessor sxop-rtd 'rbp))
  92. ;(define cgol:sxop-nud (record-accessor sxop-rtd 'nud))
  93. ;;sxop-match overloaded on sxop-rbp
  94. ;(define cgol:sxop-match cgol:sxop-rbp)
  95.  
  96. ;(define cgol:sxop-set-name! (record-modifier sxop-rtd 'name))
  97. ;(define cgol:sxop-set-lame! (record-modifier sxop-rtd 'lame))
  98. ;(define cgol:sxop-set-lbp! (record-modifier sxop-rtd 'lbp))
  99. ;(define cgol:sxop-set-led! (record-modifier sxop-rtd 'led))
  100. ;(define cgol:sxop-set-rbp! (record-modifier sxop-rtd 'rbp))
  101. ;(define cgol:sxop-set-nud! (record-modifier sxop-rtd 'nud))
  102. ;;sxop-match overloaded on sxop-rbp
  103. ;(define cgol:sxop-set-match! cgol:sxop-set-rbp!)
  104.  
  105. (define (cgol:make-sxop name lame lbp rbp nud led)
  106.   (cons (cons name lame) (cons (cons lbp rbp) (cons nud led))))
  107. (define cgol:sxop-name caar)
  108. (define cgol:sxop-lame cdar)
  109. (define cgol:sxop-lbp caadr)
  110. (define cgol:sxop-rbp cdadr)
  111. (define cgol:sxop-nud caddr)
  112. (define cgol:sxop-led cdddr)
  113. ;;sxop-match overloaded on sxop-rbp
  114. (define cgol:sxop-match cgol:sxop-rbp)
  115.  
  116. (define (cgol:sxop-set-name! pob val) (set-car! (car pob) val))
  117. (define (cgol:sxop-set-lame! pob val) (set-cdr! (car pob) val))
  118. (define (cgol:sxop-set-lbp! pob val) (set-car! (cadr pob) val))
  119. (define (cgol:sxop-set-rbp! pob val) (set-cdr! (cadr pob) val))
  120. (define (cgol:sxop-set-nud! pob val) (set-car! (cddr pob) val))
  121. (define (cgol:sxop-set-led! pob val) (set-cdr! (cddr pob) val))
  122. ;;sxop-match overloaded on sxop-rbp
  123. (define cgol:sxop-set-match! cgol:sxop-set-rbp!)
  124.  
  125. (define cgol:sxop-get (hash-inquirer equal?))
  126. (define cgol:sxop-set! (hash-associator equal?))
  127.  
  128. ;(define cgol:null-sxop #f)
  129.  
  130. (define (cgol:defield tokens value cap accessor modifier)
  131.   (for-each
  132.    (lambda (tok)
  133.      (let* ((token (if (symbol? tok) (symbol->string tok) tok))
  134.         (a (cgol:sxop-get *syn-defs* token)))
  135.        (cond ((not a)
  136.           (set! a (cgol:make-sxop #f #f #f #f #f #f))
  137. ;          (if (equal? "" tok) (set! cgol:null-sxop a))
  138.           (cgol:sxop-set! *syn-defs* token a)))
  139.        (cond ((eqv? value (accessor a)))
  140.          ((not (accessor a)) (modifier a value))
  141.          (else (math:warn cap " of " token
  142.                  " redefined from " (accessor a)
  143.                  " to " value)
  144.            (modifier a value)))))
  145.    (if (pair? tokens)
  146.        tokens
  147.        (list tokens))))
  148.  
  149. (define (cgol:defname tokens value)
  150.   (cgol:defield tokens value "name" cgol:sxop-name cgol:sxop-set-name!))
  151. (define (cgol:deflame tokens value)
  152.   (cgol:defield tokens value "lame" cgol:sxop-lame cgol:sxop-set-lame!))
  153. (define (cgol:deflbp tokens value)
  154.   (cgol:defield tokens value "lbp" cgol:sxop-lbp cgol:sxop-set-lbp!))
  155. (define (cgol:defled tokens value)
  156.   (cgol:defield tokens value "led" cgol:sxop-led cgol:sxop-set-led!))
  157. (define (cgol:defrbp tokens value)
  158.   (cgol:defield tokens value "rbp" cgol:sxop-rbp cgol:sxop-set-rbp!))
  159. ;;sxop-match overloaded on sxop-rbp
  160. (define (cgol:defmatch tokens value)
  161.   (cgol:defield tokens value "match" cgol:sxop-rbp cgol:sxop-set-rbp!))
  162. (define (cgol:defnud tokens value)
  163.   (cgol:defield tokens value "nud" cgol:sxop-nud cgol:sxop-set-nud!))
  164.  
  165. ;;;Calls to set up tables.
  166.  
  167. (define (cgol:delim x lbp)
  168.   (cgol:deflbp x lbp)
  169.   (cgol:defrbp x -2)
  170.   (cgol:defled x #f)
  171.   (cgol:defnud x #f))
  172. (define (cgol:separator x lbp)
  173.   (cgol:deflbp x lbp)
  174.   (cgol:defrbp x -1)
  175.   (cgol:defled x #f)
  176.   (cgol:defnud x #f))
  177. (define (cgol:prefix op sop rbp)
  178.   (cgol:defname op sop)
  179.   (cgol:defrbp op rbp)
  180.   (cgol:defnud op cgol:parse-prefix))
  181. (define (cgol:postfix op sop lbp)
  182.   (cgol:deflame op sop)
  183.   (cgol:deflbp op lbp)
  184.   (cgol:defled op cgol:parse-postfix))
  185. (define (cgol:infix op sop lbp rbp)
  186.   (cgol:deflame op sop)
  187.   (cgol:deflbp op lbp)
  188.   (cgol:defrbp op rbp)
  189.   (cgol:defled op cgol:parse-infix))
  190. (define (cgol:nary op sop bp)
  191.   (cgol:deflame op sop)
  192.   (cgol:deflbp op bp)
  193.   (cgol:defrbp op bp)
  194.   (cgol:defled op cgol:parse-nary))
  195. (define (cgol:nofix op sop)
  196.   (cgol:defname op sop)
  197.   (cgol:defnud op cgol:parse-nofix))
  198. (define (cgol:commentfix op sop)
  199.   (cgol:defname op sop)
  200.   (cgol:deflame op sop)
  201.   (cgol:deflbp op 220)
  202.   (cgol:defrbp op 220)
  203.   (cgol:defnud op cgol:parse-precomment)
  204.   (cgol:defled op cgol:parse-postcomment))
  205. (define (cgol:rest op sop bp)
  206.   (cgol:defname op sop)
  207.   (cgol:defnud op cgol:parse-rest)
  208.   (cgol:defrbp op bp))
  209. (define (cgol:matchfix op sop match)
  210.   (cgol:defname op sop)
  211.   (cgol:delim match 0)
  212.   (cgol:defmatch op match)
  213.   (cgol:defnud op cgol:parse-matchfix))
  214. (define (cgol:inmatchfix op sop match lbp)
  215.   (cgol:deflame op sop)
  216.   (cgol:defmatch op match)
  217.   (cgol:delim match 0)
  218.   (cgol:deflbp op lbp)
  219.   (cgol:defled op cgol:parse-inmatchfix))
  220.  
  221. ;;;; Here is the code which actually lexes and parses.
  222.  
  223. (define cgol:char0 (integer->char 0))
  224. (define (lex:tab-geteof x)
  225.   (lex:tab-get *lex-rules* (if (eof-object? x) cgol:char0 x)))
  226. (define (lex)
  227.   (let* ((char (lex:read-char))
  228.      (rec (lex:tab-geteof char))
  229.      (proc (and rec (lex:cc rec)))
  230.      (clist (list char)))
  231.     (cond
  232.      ((not proc) char)
  233.      ((procedure? proc)
  234.       (do ((cl clist (begin (set-cdr! cl (list (lex:read-char))) (cdr cl))))
  235.       ((proc (lex:peek-char))
  236.        (funcall (lex:sfp rec) clist))))
  237.      ((eqv? 0 proc) (lex))
  238.      (else
  239.       (do ((cl clist (begin (set-cdr! cl (list (lex:read-char))) (cdr cl))))
  240.       ((not (let* ((prec (lex:tab-geteof (lex:peek-char)))
  241.                (cclass (and prec (lex:cc prec))))
  242.           (or (eqv? cclass proc)
  243.               (eqv? cclass (- proc 1)))))
  244.        (if (lex:sfp rec)
  245.            (funcall (lex:sfp rec) clist)
  246.            (list->string clist))))))))
  247.  
  248. ;;; Now for the way we use LEX.
  249. (define cgol:token #f)
  250. (define cgol:pob #f)
  251. (define (cgol:advance)
  252.   (set! cgol:token (lex))
  253.   (set! cgol:pob (cgol:sxop-get *syn-rules* cgol:token))
  254.   cgol:token)
  255.  
  256. ;;; Now actual parsing.
  257. (define (cgol:nudcall)
  258.   (let* ((obj cgol:token) (pob cgol:pob))
  259.     (cond
  260.      ((cgol:at-sep?) (cgol:warn 'extra-separator)
  261.              (cgol:advance)
  262.              (cgol:nudcall))
  263.      (pob (let ((proc (cgol:sxop-nud pob)))
  264.         (cond (proc (proc pob))
  265.           (else (cgol:advance)
  266.             (let ((name (cgol:sxop-name pob)))
  267.               (or (and (not (procedure? name)) name)
  268.                   (cgol:sxop-lame pob)
  269.                   '?))))))
  270.      (else (cgol:advance)
  271.        (if (string? obj) (string->symbol obj) obj)))))
  272. (define (cgol:ledcall left)
  273.   (let* ((pob cgol:pob))
  274.     (cond
  275.      ((cgol:at-sep?) (cgol:warn 'extra-separator)
  276.              (cgol:advance)
  277.              (cgol:ledcall left))
  278.      (pob (let ((proc (cgol:sxop-led pob)))
  279.          (cond (proc (proc pob left))
  280.                (else (cgol:warn 'not-an-operator)
  281.                  (cgol:advance)
  282.                  left))))
  283.       (else left))))
  284.  
  285. (define (cgol:parse bp)
  286.   (do ((left (cgol:nudcall)
  287.          (cgol:ledcall left)))
  288.       ((or (>= bp 200)            ;to avoid unneccesary lookahead
  289.        (>= bp (if cgol:pob (or (cgol:sxop-lbp cgol:pob) 0) 0)))
  290.        left)))
  291.  
  292. (define (cgol:at-sep?)
  293.   (and cgol:pob (eqv? (cgol:sxop-rbp cgol:pob) -1)))
  294.  
  295. (define (cgol:at-delim?)
  296.   (or (eof-object? cgol:token)
  297.       (and cgol:pob (eqv? (cgol:sxop-rbp cgol:pob) -2))))
  298.  
  299. (define (cgol:parse-list sep bp)
  300.   (let ((f (cgol:parse bp)))
  301.     (cons f (cond ((equal? sep cgol:token)
  302.            (cgol:advance)
  303.            (cond
  304.             ((equal? sep cgol:token) (cgol:warn 'expression-missing)
  305.              (cgol:advance)
  306.              (cons '? (cgol:parse-list sep bp)))
  307.             ((cgol:at-delim?)
  308.              (cgol:warn 'expression-missing)
  309.              '(?))
  310.             (else (cgol:parse-list sep bp))))
  311.           (sep '())
  312.           ((cgol:at-delim?) '())
  313.           (else (cgol:parse-list sep bp))))))
  314.  
  315. (define cgol:arg-separator #f)
  316. (define cgol:arg-lbp #f)
  317. (define (cgol:parse-delimited delim)
  318.   (cond ((cgol:at-sep?)
  319.      (cgol:warn 'expression-missing)
  320.      (cgol:advance)
  321.      (cons '? (cgol:parse-delimited delim)))
  322.     ((cgol:at-delim?)
  323.      (if (eqv? delim cgol:token) #t
  324.          (cgol:warn 'mismatched-delimiter))
  325.      (cgol:advance)
  326.      '())
  327.     (else
  328.      (let ((ans (cgol:parse-list cgol:arg-separator cgol:arg-lbp)))
  329.        (cond ((eqv? delim cgol:token))
  330.          ((cgol:at-delim?)
  331.           (cgol:warn 'mismatched-delimiter))
  332.          (else
  333.           (cgol:warn 'delimiter-expected--ignoring-rest)
  334.           (do () ((cgol:at-delim?)) (cgol:parse cgol:arg-lbp))))
  335.        (cgol:advance)
  336.        ans))))
  337.  
  338. (define (cgol:top-parse delim)
  339.   (let ((tmp (cgol:sxop-get *syn-defs* cgol:arg-separator)))
  340.     (if tmp (set! cgol:arg-lbp (cgol:sxop-lbp tmp))))
  341.   (cgol:advance)            ;to get first token
  342.   (cond ((eof-object? cgol:token) (let ((eof cgol:token)) eof))
  343.     ((equal? cgol:token delim) #f)
  344.     ((cgol:at-sep?) (cgol:warn 'extra-separator) #f)
  345.     ((cgol:at-delim?) (cgol:warn 'extra-delimiter) #f)
  346.     (else
  347.      (let ((ans (cgol:parse 0)))
  348.        (cond ((eof-object? cgol:token))
  349.          ((equal? delim cgol:token))
  350.          (else
  351.           (cgol:warn 'delimiter-expected--ignoring-rest)
  352.           (do () ((or (equal? delim cgol:token)
  353.                   (eof-object? cgol:token)))
  354.             (cgol:advance))))
  355.        ans))))
  356.  
  357. (define (call-or-list1 proc arg)
  358.   (if proc (if (procedure? proc) (proc arg) (list proc arg))
  359.       arg))
  360. (define (call-or-list2 proc arg1 arg2)
  361.   (if proc (if (procedure? proc) (proc arg1 arg2) (list proc arg1 arg2))
  362.       (list arg1 arg2)))
  363. (define (apply-or-cons proc args)
  364.   (if proc (if (procedure? proc) (apply proc args) (cons proc args))
  365.       args))
  366.  
  367. ;;;next level of abstraction
  368.  
  369. (define (cgol:parse-matchfix pob)
  370.   (define name (cgol:sxop-name pob))
  371.   (cgol:advance)
  372.   (cond
  373.    (name
  374.     (apply-or-cons name (cgol:parse-delimited (cgol:sxop-match pob))))
  375.    ((cgol:at-sep?)
  376.     (cgol:warn 'extra-separator)
  377.     (cgol:parse-matchfix pob))
  378.    ((cgol:at-delim?) (cgol:warn 'expression-missing) (cgol:advance) '?)
  379.    (else                ;just parenthesized expression
  380.     (let ((ans (cgol:parse cgol:arg-lbp)))
  381.       (do () ((not (cgol:at-sep?)))
  382.     (cgol:warn 'extra-separator) (cgol:advance))
  383.       (do ((left ans (cgol:ledcall left))) ;restart parse
  384.       ((>= cgol:arg-lbp (if cgol:pob (or (cgol:sxop-lbp cgol:pob) 0) 0))
  385.        (set! ans left)))
  386.       (cond ((equal? (cgol:sxop-match pob) cgol:token) (cgol:advance) ans)
  387.         ((cgol:at-delim?) (cgol:warn 'mismatched-delimiter)
  388.                   (cgol:advance) ans)
  389.         (else (cgol:warn 'delimiter-expected--ignoring-rest)
  390.           (do () ((cgol:at-delim?)) (cgol:parse cgol:arg-lbp))
  391.           (cgol:advance)
  392.           ans))))))
  393. (define (cgol:parse-rest pob)
  394.   (cgol:advance)            ;past this token
  395.   (cons (cgol:sxop-name pob)
  396.     (cond ((cgol:at-delim?) '())
  397.           (else
  398.            (cond ((cgol:at-sep?)
  399.               (cgol:warn 'extra-separator)
  400.               (cgol:advance)))
  401.            (cgol:parse-list #f (cgol:sxop-rbp pob))))))
  402. (define (cgol:parse-inmatchfix pob left)
  403.   (define lame (cgol:sxop-lame pob))
  404.   (cgol:advance)            ;past this token
  405.   (apply-or-cons
  406.    lame (cons left (cgol:parse-delimited (cgol:sxop-match pob)))))
  407. (define (cgol:parse-prefix pob)
  408.   (define name (cgol:sxop-name pob))
  409.   (cgol:advance)            ;past this token
  410.   (cond ((cgol:at-delim?) (or (and (not (procedure? name)) name)
  411.                   (cgol:sxop-lame pob)))
  412.     (else
  413.      (call-or-list1 name (cgol:parse (cgol:sxop-rbp pob))))))
  414. (define (cgol:parse-nofix pob)
  415.   (define name (cgol:sxop-name pob))
  416.   (cgol:advance)            ;past this token
  417.   (apply-or-cons name '()))
  418. (define (cgol:parse-precomment pob)
  419.   (define name (cgol:sxop-name pob))
  420.   (name)
  421.   (cgol:advance)            ;past this token
  422.   (cgol:parse (cgol:sxop-rbp pob)))
  423. (define (cgol:parse-postcomment pob left)
  424.   (define lame (cgol:sxop-lame pob))
  425.   (lame)
  426.   (cgol:advance)            ;past this token
  427.   left)
  428. (define (cgol:parse-postfix pob left)
  429.   (define lame (cgol:sxop-lame pob))
  430.   (cgol:advance)            ;past this token
  431.   (call-or-list1 lame left))
  432. (define (cgol:parse-infix pob left)
  433.   (define lame (cgol:sxop-lame pob))
  434.   (cgol:advance)
  435.   (cond ((cgol:at-delim?)
  436.      (cgol:warn 'expression-missing)
  437.      (call-or-list2 lame left '?))
  438.     (else
  439.      (call-or-list2 lame left (cgol:parse (cgol:sxop-rbp pob))))))
  440. (define (cgol:parse-nary pob left)
  441.   (define self cgol:token)
  442.   (define lame (cgol:sxop-lame pob))
  443.   (cgol:advance)
  444.   (cond ((cgol:at-delim?)
  445.      (cgol:warn 'expression-missing)
  446.      (call-or-list2 lame left '?))
  447.     (else
  448.      (apply-or-cons
  449.       lame (cons left (cgol:parse-list self (cgol:sxop-rbp pob)))))))
  450.